home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Thomas / MacGambit⁄Thomas / MacGambit⁄Thomas Sources / Thomas 1.1 sources / compiler.scm < prev    next >
Encoding:
Text File  |  1995-03-15  |  39.8 KB  |  799 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*                      Director, Cambridge Research Lab
  21. ;*                      Digital Equipment Corp
  22. ;*                      One Kendall Square, Bldg 700
  23. ;*                      Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: compiler.scm,v 1.26 1992/09/11 21:24:20 jmiller Exp $
  39. ; fixed bug in function thomas Ray Laning@Advanced Robotic Technologies
  40. ;;;; This file contains the Thomas -> Scheme compiler and
  41. ;;;; routines needed ONLY at compilation time.  Support routines that
  42. ;;;; are also needed when Dylan programs run are located in generic.scm
  43. ;;;; (generic operator dispatch), class.scm (class heterarchy), and
  44. ;;;; support.scm (general support routines)
  45.  
  46. ;;; Normal external entry points for compilation
  47.  
  48. (define (compile-expression e multi-value mod-vars continue)
  49.   ;; e is a single Thomas expression
  50.   ;; multi-value is an expression to be passed as the multi-value
  51.   ;;  vector (or #F) at runtime
  52.   ;; mod-vars is a list of pre-existing module variables
  53.   ;; continue is a function that receives:
  54.   ;;   a: the output code
  55.   ;;   b: the preamble (def'ns of free variables, refs, sets)
  56.   ;;   c: the list of newly created module variables
  57.   (define (define-module-variable name)
  58.     `(DEFINE ,name ',the-unassigned-value))
  59.   (define (define-module-getter name)
  60.     `(DEFINE (,(name->module-getter name)) ,name))
  61.   (define (define-module-setter name)
  62.     `(DEFINE (,(name->module-setter name) NEW-VALUE)
  63.        (SET! ,name NEW-VALUE)))
  64.   (really-compile e mod-vars '() multi-value
  65.    (lambda (compiled-output free-vars)
  66.      (let* ((need-getter/setters
  67.              (if (null? free-vars)
  68.                  '()
  69.                  (set-difference free-vars mod-vars member)))
  70.             (need-definition
  71.              (set-difference need-getter/setters
  72.                              dylan::predefined-variables member)))
  73.        (continue need-definition
  74.                  `(,@(map define-module-variable need-definition)
  75.                    ,@(map define-module-getter need-getter/setters)
  76.                    ,@(map define-module-setter need-getter/setters))
  77.                  compiled-output)))))
  78.  
  79. (define dylan::scheme-names-of-predefined-names
  80.   `((* dylan:*)                                     ; Method
  81.     (+ dylan:+)                                     ; Method
  82.     (- dylan:-)                                     ; Method
  83.     (/ dylan:/)                                     ; Method
  84.     (/= dylan:/=)                                   ; Method
  85.     (< dylan:<)                                     ; Method
  86.     (<= dylan:<=)                                   ; Method
  87.     (<abort> <abort>)                               ; Class
  88.     (<array> <array>)                               ; Class
  89.     (<byte-string> <byte-string>)                   ; Class
  90.     (<character> <character>)                       ; Class
  91.     (<class> <class>)                               ; Class
  92.     (<collection> <collection>)                     ; Class
  93.     (<complex> <complex>)                           ; Class
  94.     (<condition> <condition>)                       ; Class
  95.     (<deque> <deque>)                               ; Class
  96.     (<double-float> <double-float>)                 ; Class
  97.     (<empty-list> <empty-list>)                     ; Class
  98.     (<error> <error>)                               ; Class
  99.     (<explicit-key-collection>                      ; Class
  100.      <explicit-key-collection>)
  101.     (<extended-float> <extended-float>)             ; Class
  102.     (<float> <float>)                               ; Class
  103.     (<function> <function>)                         ; Class
  104.     (<generic-function> <generic-function>)         ; Class
  105.     (<integer> <integer>)                           ; Class
  106.     (<keyword> <keyword>)                           ; Class
  107.     (<list> <list>)                                 ; Class
  108.     (<method> <method>)                             ; Class
  109.     (<mutable-collection> <mutable-collection>)     ; Class
  110.     (<mutable-explicit-key-collection>              ; Class
  111.      <mutable-explicit-key-collection>)
  112.     (<mutable-sequence> <mutable-sequence>)         ; Class
  113.     (<number> <number>)                             ; Class
  114.     (<object> <object>)                             ; Class
  115.     (<pair> <pair>)                                 ; Class
  116.     (<range> <range>)                               ; Class
  117.     (<ratio> <ratio>)                               ; Class
  118.     (<rational> <rational>)                         ; Class
  119.     (<real> <real>)                                 ; Class
  120.     (<rectangular-complex> <rectangular-complex>)   ; Class
  121.     (<restart> <restart>)                           ; Class
  122.     (<sequence> <sequence>)                         ; Class
  123.     (<serious-condition> <serious-condition>)       ; Class
  124.     (<simple-error> <simple-error>)                 ; Class
  125.     (<simple-object-vector> <simple-object-vector>) ; Class
  126.     (<simple-restart> <simple-restart>)             ; Class
  127.     (<simple-warning> <simple-warning>)             ; Class
  128.     (<single-float> <single-float>)                 ; Class
  129.     (<singleton> <singleton>)                       ; Class
  130.     (<slot-descriptor> <slot-descriptor>)           ; Class
  131.     (<stretchy-vector> <stretchy-vector>)           ; Class
  132.     (<string> <string>)                             ; Class
  133.     (<symbol> <symbol>)                             ; Class
  134.     (<table> <table>)                               ; Class
  135.     (<type-error> <type-error>)                     ; Class
  136.     (<unicode-string> <unicode-string>)             ; Class
  137.     (<vector> <vector>)                             ; Class
  138.     (<warning> <warning>)                           ; Class
  139.     (= dylan:=)                                     ; Method
  140.     (=hash dylan:=hash)                             ; Generic-Function
  141.     (> dylan:>)                                     ; Method
  142.     (>= dylan:>=)                                   ; Method
  143.     (Id? dylan:id?)                                 ; Method
  144.     (abort dylan:abort)                             ; Sealed-Function
  145.     (abs dylan:abs)                                 ; Generic-Function
  146.     (acos dylan:acos)                               ; Generic-Function
  147.     (acosh dylan:acosh)                             ; Generic-Function
  148.     (add dylan:add)                                 ; Generic-Function
  149.     (add! dylan:add!)                               ; G.F. Method
  150.     (add-method dylan:add-method)                   ; Generic-Function
  151.     (add-new dylan:add-new)                         ; Generic-Function
  152.     (add-new! dylan:add-new!)                       ; Generic-Function
  153.     (add-slot dylan:add-slot)                       ; Generic-Function
  154.     (all-superclasses dylan:all-superclasses)       ; Generic-Function
  155.     (always dylan:always)                           ; Method
  156.     (angle dylan:angle)                             ; Generic-Method
  157.     (any? dylan:any?)                               ; Generic-Function
  158.     (append dylan:append)                           ; Generic-Function
  159.     (applicable-method? dylan:applicable-method?)   ; Generic-Function
  160.     (apply dylan:apply)                             ; Function
  161.     (aref dylan:aref)                               ; Generic-Function
  162.     (as dylan:as)                                   ; Generic-Function
  163.     (as-lowercase dylan:as-lowercase)               ; G.F. Method
  164.     (as-lowercase! dylan:as-lowercase!)             ; G.F. Method
  165.     (as-uppercase dylan:as-uppercase)               ; G.F. Method
  166.     (as-uppercase! dylan:as-uppercase!)             ; G.F. Method
  167.     (ash dylan:ash)                                 ; Generic-Method
  168.     (asin dylan:asin)                               ; Generic-Function
  169.     (asinh dylan:asinh)                             ; Generic-Function
  170.     (atan dylan:atan)                               ; Generic-Function
  171.     (atan2 dylan:atan2)                             ; Generic-Function
  172.     (atanh dylan:atanh)                             ; Generic-Function
  173.     (binary* dylan:binary*)                         ; Generic-Function
  174.     (binary+ dylan:binary+)                         ; Generic-Function
  175.     (binary- dylan:binary-)                         ; Generic-Function
  176.     (binary-gcd dylan:binary-gcd)                   ; Generic-Method
  177.     (binary-lcm dylan:binary-lcm)                   ; Generic-Method
  178.     (binary/ dylan:binary/)                         ; Generic-Function
  179.     (binary< dylan:binary<)                         ; Generic-Function
  180.     (binary= dylan:binary=)                         ; Generic-Function
  181.     (break dylan:break)                             ; Sealed-Function
  182.     (caaar dylan:caaar)                             ; Method
  183.     (caadr dylan:caadr)                             ; Method
  184.     (caar dylan:caar)                               ; Method
  185.     (cadar dylan:cadar)                             ; Method
  186.     (caddr dylan:caddr)                             ; Method
  187.     (cadr dylan:cadr)                               ; Method
  188.     (car dylan:car)                                 ; Method
  189.     (cdaar dylan:cdaar)                             ; Method
  190.     (cdadr dylan:cdadr)                             ; Method
  191.     (cdar dylan:cdar)                               ; Method
  192.     (cddar dylan:cddar)                             ; Method
  193.     (cdddr dylan:cdddr)                             ; Method
  194.     (cddr dylan:cddr)                               ; Method
  195.     (cdr dylan:cdr)                                 ; Method
  196.     (ceiling dylan:ceiling)                         ; Generic-Function
  197.     (ceiling/ dylan:ceiling/)                       ; Generic-Function
  198.     (cerror dylan:cerror)                           ; Sealed-Function
  199.     (check-type dylan:check-type)                   ; Sealed-Function
  200.     (choose dylan:choose)                           ; Generic-Function
  201.     (choose-by dylan:choose-by)                     ; Generic-Function
  202.     (class-for-copy dylan:class-for-copy)           ; Generic-Function
  203.     (complement dylan:complement)                   ; Method
  204.     (compose dylan:compose)                         ; Method
  205.     (concatenate dylan:concatenate)                 ; Generic-Function
  206.     (concatenate-as dylan:concatenate-as)           ; Generic-Function
  207.     (conjoin dylan:conjoin)                         ; Method
  208.     (cons dylan:cons)                               ; Method
  209.     (copy-sequence dylan:copy-sequence)             ; Generic-Function
  210.     (copy-state dylan:copy-state)                   ; Generic-Function
  211.     (cos dylan:cos)                                 ; Generic-Function
  212.     (cosh dylan:cosh)                               ; Generic-Function
  213.     (current-element dylan:current-element)         ; Generic-Function
  214.     (current-key dylan:current-key)                 ; Generic-Function
  215.     (curry dylan:curry)                             ; Method
  216.     (default-handler dylan:default-handler)         ; Generic-Function
  217.     (denominator dylan:denominator)                 ; Generic-Method
  218.     (dimensions dylan:dimensions)                   ; Generic-Function
  219.     (direct-subclasses dylan:direct-subclasses)     ; Generic-Function
  220.     (direct-superclasses dylan:direct-superclasses) ; Generic-Function
  221.     (disjoin dylan:disjoin)                         ; Method
  222.     (do dylan:do)                                   ; Generic-Function
  223.     (do-handlers dylan:do-handlers)                 ; Sealed-Function
  224.     (element dylan:element)                         ; Generic-Function
  225.     (empty? dylan:empty?)                           ; Generic-Function
  226.     (error dylan:error)                             ; Sealed-Function
  227.     (even? dylan:even?)                             ; Generic-Function
  228.     (every? dylan:every?)                           ; Generic-Function
  229.     (exp dylan:exp)                                 ; Generic-Function
  230.     (expt dylan:expt)                               ; Generic-Function
  231.     (fill! dylan:fill!)                             ; Generic-Function
  232.     (final-state dylan:final-state)                 ; G.F. Method
  233.     (find-key dylan:find-key)                       ; Generic-Function
  234.     (find-method dylan:find-method)                 ; Generic-Function
  235.     (find-pair dylan:find-pair)                     ; Generic-Function
  236.     (first dylan:first)                             ; Generic-Function
  237.     (floor dylan:floor)                             ; Generic-Function
  238.     (floor/ dylan:floor/)                           ; Generic-Function
  239.     (freeze-methods dylan:freeze-methods)           ; Generic-Function
  240.     (function-arguments dylan:function-arguments)   ; Generic-Function
  241.     (gcd dylan:gcd)                                 ; Method
  242.     (generic-function-methods                       ; Generic-Function
  243.      dylan:generic-function-methods)
  244.     (identity dylan:identity)                       ; Method
  245.     (imag-part dylan:imag-part)                     ; Generic-Method
  246.     (init-function dylan:init-function)             ; Generic-Function
  247.     (init-keyword dylan:init-keyword)               ; Generic-Function
  248.     (init-value dylan:init-value)                   ; Generic-Function
  249.     (initial-state dylan:initial-state)             ; Generic-Function
  250.     (initialize dylan:initialize)                   ; Generic-Function
  251.     (instance? dylan:instance?)                     ; Generic-Function
  252.     (integral? dylan:integral?)                     ; Generic-Function
  253.     (intersection dylan:intersection)               ; Generic-Function
  254.     (key-sequence dylan:key-sequence)               ; Generic-Function
  255.     (last dylan:last)                               ; Generic-Function
  256.     (lcm dylan:lcm)                                 ; Method
  257.     (list dylan:list)                               ; Method
  258.     (list* dylan:list*)                             ; Method
  259.     (log dylan:log)                                 ; Generic-Function
  260.     (logand dylan:logand)                           ; Generic-Method
  261.     (logandc1 dylan:logandc1)                       ; Generic-Method
  262.     (logandc2 dylan:logandc2)                       ; Generic-Method
  263.     (logbit? dylan:logbit?)                         ; Generic-Method
  264.     (logeqv dylan:logeqv)                           ; Generic-Method
  265.     (logior dylan:logior)                           ; Generic-Method
  266.     (lognand dylan:lognand)                         ; Generic-Method
  267.     (lognor dylan:lognor)                           ; Generic-Method
  268.     (lognot dylan:lognot)                           ; Generic-Method
  269.     (logorc1 dylan:logorc1)                         ; Generic-Method
  270.     (logorc2 dylan:logorc2)                         ; Generic-Method
  271.     (logxor dylan:logxor)                           ; Generic-Method
  272.     (make dylan:make)                               ; Generic-Function
  273.     (make-polar dylan:make-polar)                   ; Generic-Function
  274.     (make-read-only dylan:make-read-only)           ; Generic-Function
  275.     (make-rectangular dylan:make-rectangular)       ; Generic-Function
  276.     (map dylan:map)                                 ; Generic-Function
  277.     (map-as dylan:map-as)                           ; Generic-Function
  278.     (map-into dylan:map-into)                       ; Generic-Function
  279.     (max dylan:max)                                 ; Method
  280.     (member? dylan:member?)                         ; Generic-Function
  281.     (method-specializers dylan:method-specializers) ; Generic-Function
  282.     (min dylan:min)                                 ; Method
  283.     (modulo dylan:modulo)                           ; Generic-Function
  284.     (negative? dylan:negative?)                     ; Generic-Function
  285.     (next-state dylan:next-state)                   ; Generic-Function
  286.     (not dylan:not)                                 ; Function
  287.     (numerator dylan:numerator)                     ; Generic-Method
  288.     (object-class dylan:object-class)               ; Generic-Function
  289.     (odd? dylan:odd?)                               ; Generic-Function
  290.     (pop dylan:pop)                                 ; Generic-Function
  291.     (pop-last dylan:pop-last)                       ; Generic-Function
  292.     (positive? dylan:positive?)                     ; Generic-Function
  293.     (previous-state dylan:previous-state)           ; G.F. Method
  294.     (push dylan:push)                               ; Generic-Function
  295.     (push-last dylan:push-last)                     ; Generic-Function
  296.     (range dylan:range)                             ; Generic-Function
  297.     (rcurry dylan:rcurry)                           ; Method
  298.     (real-part dylan:real-part)                     ; Generic-Method
  299.     (rationalize dylan:rationalize)                 ; Generic-Method
  300.     (reduce dylan:reduce)                           ; Generic-Function
  301.     (reduce1 dylan:reduce1)                         ; Generic-Function
  302.     (remainder dylan:remainder)                     ; Generic-Function
  303.     (remove dylan:remove)                           ; Generic-Function
  304.     (remove! dylan:remove!)                         ; Generic-Function
  305.     (remove-duplicates dylan:remove-duplicates)     ; Generic-Function
  306.     (remove-duplicates! dylan:remove-duplicates!)   ; Generic-Function
  307.     (remove-key! dylan:remove-key!)                 ; Generic-Function
  308.     (remove-method dylan:remove-method)             ; Generic-Function
  309.     (remove-slot dylan:remove-slot)                 ; Generic-Function
  310.     (replace-elements! dylan:replace-elements!)     ; Generic-Function
  311.     (replace-subsequence! dylan:replace-subsequence!) ; Generic-Function
  312.     (restart-query dylan:restart-query)             ; Generic-Function
  313.     (return-allowed? dylan:return-allowed?)         ; Generic-Function
  314.     (return-description dylan:return-description)   ; Generic-Function
  315.     (return-query dylan:return-query)               ; Generic-Function
  316.     (reverse dylan:reverse)                         ; Generic-Function
  317.     (reverse! dylan:reverse!)                       ; Generic-Function
  318.     (round dylan:round)                             ; Generic-Function
  319.     (round/ dylan:round/)                           ; Generic-Function
  320.     (seal dylan:seal)                               ; Generic-Function
  321.     (second dylan:second)                           ; Generic-Function
  322.     (shallow-copy dylan:shallow-copy)               ; Generic-Function
  323.     (signal dylan:signal)                           ; Sealed-Function
  324.     (sin dylan:sin)                                 ; Generic-Function
  325.     (singleton dylan:singleton)                     ; Function
  326.     (sinh dylan:sinh)                               ; Generic-Function
  327.     (size dylan:size)                               ; G.F. Method
  328.     (slot-allocation dylan:slot-allocation)         ; Generic-Function
  329.     (slot-descriptor dylan:slot-descriptor)         ; Generic-Function
  330.     (slot-descriptors dylan:slot-descriptors)       ; Generic-Function
  331.     (slot-getter dylan:slot-getter)                 ; Generic-Function
  332.     (slot-initialized? dylan:slot-initialized?)     ; Generic-Function
  333.     (slot-setter dylan:slot-setter)                 ; Generic-Function
  334.     (slot-type dylan:slot-type)                     ; Generic-Function
  335.     (slot-value dylan:slot-value)                   ; Generic-Function
  336.     (sort dylan:sort)                               ; Generic-Function
  337.     (sort! dylan:sort!)                             ; Generic-Function
  338.     (sorted-applicable-methods                      ; Generic-Function
  339.      dylan:sorted-applicable-methods)
  340.     (sqrt dylan:sqrt)                               ; Generic-Method
  341.     (subclass? dylan:subclass?)                     ; Generic-Function
  342.     (subsequence-position dylan:subsequence-position) ; Generic-Function
  343.     (tan dylan:tan)                                 ; Generic-Function
  344.     (tanh dylan:tanh)                               ; Generic-Function
  345.     (third dylan:third)                             ; Generic-Function
  346.     (truncate dylan:truncate)                       ; Generic-Function
  347.     (truncate/ dylan:truncate/)                     ; Generic-Function
  348.     (unary- dylan:unary-)                           ; Generic-Function
  349.     (unary/ dylan:unary/)                           ; Generic-Function
  350.     (union dylan:union)                             ; Generic-Function
  351.     (values dylan:values)                           ; Function
  352.     (vector dylan:vector)                           ; Method
  353.     (zero? dylan:zero?)                             ; Generic-Function
  354.     ;;;;;;;;;;;;;;; SETTER VARIABLES
  355.     (,(name->setter 'slot-value) dylan:setter/slot-value/)
  356.     (,(name->setter 'element) dylan:setter/element/)
  357.     (,(name->setter 'current-element) dylan:setter/current-element/)
  358.     (,(name->setter 'first) dylan:setter/first/)
  359.     (,(name->setter 'second) dylan:setter/second/)
  360.     (,(name->setter 'third) dylan:setter/third/)
  361.     (,(name->setter 'aref) dylan:setter/aref/)
  362.     (,(name->setter 'car) dylan:setter/car/)
  363.     (,(name->setter 'cdr) dylan:setter/cdr/)
  364.     (,(name->setter 'caar) dylan:setter/caar/)
  365.     (,(name->setter 'cadr) dylan:setter/cadr/)
  366.     (,(name->setter 'cdar) dylan:setter/cdar/)
  367.     (,(name->setter 'cddr) dylan:setter/cddr/)
  368.     (,(name->setter 'caaar) dylan:setter/caaar/)
  369.     (,(name->setter 'caadr) dylan:setter/caadr/)
  370.     (,(name->setter 'cadar) dylan:setter/cadar/)
  371.     (,(name->setter 'caddr) dylan:setter/caddr/)
  372.     (,(name->setter 'cdaar) dylan:setter/cdaar/)
  373.     (,(name->setter 'cdadr) dylan:setter/cdadr/)
  374.     (,(name->setter 'cddar) dylan:setter/cddar/)
  375.     (,(name->setter 'cdddr) dylan:setter/cdddr/)
  376.     ;;;;;;;;;;;;;;; CRL ADDITIONS
  377.     (display dylan:display)
  378.     (newline dylan:newline)
  379.     (write-line dylan:write-line)
  380.     (print dylan:print)
  381.     ,@implementation-specific:additional-dylan-bindings
  382.     ))
  383.  
  384. (define dylan::predefined-names
  385.   (map car dylan::scheme-names-of-predefined-names))
  386.  
  387. (define dylan::predefined-variables
  388.   (map cadr dylan::scheme-names-of-predefined-names))
  389.  
  390. ;(define (thomas file-name . expressions)
  391. ;  (compile-expression `(BEGIN ,@expressions) #F '()
  392. ;    (lambda (new-vars preamble-code compiled)
  393. ;      new-vars                          ; Not used
  394. ;      (with-output-to-file file-name
  395. ;        (lambda ()
  396. ;          (display "; Output generated by the CRL Thomas->Scheme compiler.")
  397. ;          (newline)
  398. ;          (implementation-specific:generate-file
  399. ;           expressions
  400. ;           `(dylan::catch-all-conditions
  401. ;             (lambda () ,@preamble-code ,compiled))))))))
  402.  
  403. ;;;The following per JMiller 8/8/93 - RL
  404. (define (thomas file-name . expressions)
  405.   (compile-expression `(BEGIN ,@expressions) #F thomas-rep-module-variables
  406.     (lambda (new-vars preamble-code compiled)
  407.       new-vars                          ; Not used
  408.       (with-output-to-file file-name
  409.         (lambda ()
  410.           (display "; Output generated by the CRL Thomas->Scheme compiler.")
  411.           (newline)
  412.           (implementation-specific:generate-file
  413.            expressions
  414.            `(begin
  415.               ,@preamble-code
  416.               (set! thomas-rep-module-variables
  417.                     (append ',new-vars thomas-rep-module-variables))
  418.               (dylan::catch-all-conditions
  419.                (lambda () ,compiled)))))))))
  420.  
  421.  
  422. (define (thomas->scheme input output)
  423.   (let ((in-port (open-input-file input)))
  424.     (let loop ((exprs '()))
  425.       (let ((next (read in-port)))
  426.         (if (eof-object? next)
  427.             (thomas output `(BEGIN ,@(reverse exprs)))
  428.             (loop (cons next exprs)))))))
  429.  
  430. ;;; Compile a list of forms, returning a list of Scheme expressions
  431. ;;; ASSUMPUTION: multiple-values?, if not #F, is to be used only for
  432. ;;; compiling the last of the forms.
  433.  
  434. (define (compile-forms
  435.          forms module-vars bound-vars really-compile
  436.          multiple-values? continue)
  437.   (let loop ((result '())
  438.              (forms forms)
  439.              (mod-vars module-vars))
  440.     (if (null? forms)
  441.         (continue (reverse result) mod-vars)
  442.         (really-compile (car forms) mod-vars bound-vars
  443.                         (if (null? (cdr forms)) multiple-values? #F)
  444.           (lambda (compiled mod-vars)
  445.             (loop (cons compiled result)
  446.                   (cdr forms)
  447.                   mod-vars))))))
  448.  
  449. ;;; The real compiler.
  450. ;;;
  451. ;;; Input: e is a form to be compiled
  452. ;;;        module-vars are the module variables already known to exist
  453. ;;;        bound-vars are the names of lexically enclosing variables
  454. ;;;        multiple-values? is either #F, indicating that the current
  455. ;;;          expressions is being compiled in non-tail position or has
  456. ;;;          the name of an internal variable to be used at runtime to
  457. ;;;          transmit the multiple-value returning function along the
  458. ;;;          tail call chain.
  459. ;;;        continue is called with the result of the compilation, and
  460. ;;;          is passed the single SCHEME form resulting from compiling
  461. ;;;          e and the new list of module variables.
  462. ;;; Output: always either error exits or tail calls into continue
  463.  
  464. (define (really-compile e module-vars bound-vars
  465.                         multiple-values? continue)
  466.   (cond
  467.    ((or (null? e) (boolean? e) (string? e)
  468.         (char? e) (number? e))          ; syntax might be an issue...
  469.     (continue e module-vars))
  470.    ((or (vector? e) (keyword? e))       ; Keywords self-evaluate in
  471.                                         ; Dylan, but not in Scheme
  472.     (continue `(QUOTE ,e) module-vars))
  473.    ((variable-name? e)
  474.     ;; As in Scheme, but the compiler needs to distinguish  bound from
  475.     ;; free
  476.     (let* ((name (variable->name e))
  477.            (new-mod-vars (add-variable name bound-vars module-vars)))
  478.       (continue
  479.        (if (memq name new-mod-vars)
  480.            `(DYLAN::FREE-VARIABLE-REF ,name ',name)
  481.            name)
  482.        new-mod-vars)))
  483.    ((symbol? e)
  484.     (dylan::error "illegal Thomas variable" e))
  485.    ((and (pair? e) (assq (car e) compilation-functions)) =>
  486.     (lambda (binding)
  487.       (((cdr binding)) (cdr e) module-vars bound-vars
  488.                        really-compile multiple-values? continue)))
  489.    ((and (list? e) (not (null? e)))
  490.     (compile-forms e module-vars bound-vars really-compile #F
  491.                    (lambda (forms module-vars)
  492.                      (continue
  493.                       `(DYLAN::APPLY ,multiple-values?
  494.                                      ,@(map (lambda (x) `(LAMBDA () ,x))
  495.                                             forms))
  496.                                module-vars))))
  497.    (else
  498.     (dylan::error "ill-formed expression" e))))
  499.  
  500. (define compiled-sharp-f
  501.   (really-compile #F '() '() #F (lambda (compiled free)
  502.                                   free  ; Ignored
  503.                                   compiled)))
  504.  
  505. (define compilation-functions
  506.   `((AND            . ,(lambda () compile-AND-form))
  507.     (BEGIN          . ,(lambda () compile-BEGIN-form))
  508.     (BIND           . ,(lambda () compile-BIND-form))
  509.     (BIND-EXIT      . ,(lambda () compile-BIND-EXIT-form))
  510.     (BIND-METHODS   . ,(lambda () compile-BIND-METHODS-form))
  511.     (CASE           . ,(lambda () compile-CASE-form))
  512.     (COND           . ,(lambda () compile-COND-form))
  513.     (DEFINE         . ,(lambda () compile-DEFINE-form))
  514.     (DEFINE-CLASS   . ,(lambda () compile-DEFINE-CLASS-form))
  515.     (DEFINE-GENERIC-FUNCTION .
  516.       ,(lambda () compile-DEFINE-GENERIC-FUNCTION-form))
  517.     (DEFINE-METHOD  . ,(lambda () compile-DEFINE-METHOD-form))
  518.     (DEFINE-SLOT    . ,(lambda () compile-DEFINE-SLOT-form))
  519.     (DOTIMES        . ,(lambda () compile-DOTIMES-form))
  520.     (FOR            . ,(lambda () compile-FOR-form))
  521.     (FOR-EACH       . ,(lambda () compile-FOR-EACH-form))
  522.     (HANDLER-BIND   . ,(lambda () compile-HANDLER-BIND-form))
  523.     (HANDLER-CASE   . ,(lambda () compile-HANDLER-CASE-form))
  524.     (IF             . ,(lambda () compile-IF-form))
  525.     (METHOD         . ,(lambda () compile-METHOD-form))
  526.     (OR             . ,(lambda () compile-OR-form))
  527.     (QUOTE          . ,(lambda () compile-QUOTE-form))
  528.     (SELECT         . ,(lambda () compile-SELECT-form))
  529.     (SET!           . ,(lambda () compile-SET!-form))
  530.     (SETTER         . ,(lambda () compile-SETTER-form))
  531.     (UNLESS         . ,(lambda () compile-UNLESS-form))
  532.     (UNTIL          . ,(lambda () compile-UNTIL-form))
  533.     (UNWIND-PROTECT . ,(lambda () compile-UNWIND-PROTECT-form))
  534.     (WHEN           . ,(lambda () compile-WHEN-form))
  535.     (WHILE          . ,(lambda () compile-WHILE-form))))
  536.  
  537. (define (compile-AND-form forms module-vars bound-vars really-compile
  538.                           multiple-values? continue)
  539.    (if (null? forms) (dylan::error "AND must have forms"))
  540.    (compile-forms
  541.     forms module-vars bound-vars really-compile multiple-values?
  542.     (lambda (code mod-vars) (continue `(AND ,@code) mod-vars))))
  543.  
  544. (define (compile-BEGIN-form forms module-vars bound-vars really-compile
  545.                 multiple-values? continue)
  546.    (if (null? forms)
  547.        (continue compiled-sharp-f module-vars)
  548.        (compile-forms
  549.         forms module-vars bound-vars
  550.         really-compile multiple-values?
  551.         (lambda (compiled module-vars)
  552.           (continue `(BEGIN ,@compiled) module-vars)))))
  553.  
  554. ; compile-BIND-form in file comp-class
  555.  
  556. (define (compile-BIND-EXIT-form
  557.          forms module-vars bound-vars really-compile multiple-values?
  558.          continue)
  559.   (must-be-list-of-at-least-length forms 1 "BIND-EXIT form invalid")
  560.   (let ((var (car forms))
  561.         (forms (cdr forms)))
  562.     (must-be-list-of-length var 1 "BIND-EXIT bad variable")
  563.     (if (not (variable-name? (car var)))
  564.         (dylan::error "BIND-EXIT -- bad variable name" var forms))
  565.     (let ((name (variable->name (car var))))
  566.       (really-compile
  567.        `(BEGIN ,@forms)
  568.        module-vars (cons name bound-vars) multiple-values?
  569.        (lambda (body module-vars)
  570.          (continue
  571.           `(DYLAN::CALL/CC
  572.             (LAMBDA (!BIND-EXIT)
  573.               (LET ((,name
  574.                      (LAMBDA (!MULTIPLE-VALUES !NEXT-METHOD . VALUES)
  575.                        !MULTIPLE-VALUES !NEXT-METHOD
  576.                        (!BIND-EXIT
  577.                         (DYLAN::SCHEME-APPLY
  578.                          DYLAN:VALUES ,multiple-values?
  579.                          NEXT-METHOD:NOT-GENERIC
  580.                          VALUES)))))
  581.                 ,body)))
  582.           module-vars))))))
  583.  
  584. ; compile-BIND-METHODS-form in file comp-method.scm
  585. ; compile-CASE-form in file comp-sf
  586. ; compile-COND-form in file comp-sf
  587.  
  588. (define (compile-DEFINE-form
  589.          forms module-vars bound-vars really-compile
  590.          multiple-values? continue)
  591.   multiple-values?                      ; No reductions
  592.   (must-be-list-of-length forms 2 "Bad DEFINE syntax")
  593.   (let ((name (car forms))
  594.         (value (cadr forms)))
  595.     (if (not (variable-name? name))
  596.         (dylan::error "bad DEFINE variable" forms))
  597.     (really-compile value
  598.       (add-module-variable (variable->name name) #F module-vars)
  599.       bound-vars #F
  600.       (lambda (compiled-value new-module-vars)
  601.         (continue
  602.          `(BEGIN
  603.             (,(name->module-setter name) ,compiled-value)
  604.             ',name)
  605.          new-module-vars)))))
  606.  
  607. ; compile-DEFINE-CLASS-form in file comp-class
  608. ; compile-DEFINE-GENERIC-FUNCTION-form in file comp-class
  609. ; compile-DEFINE-METHOD-form in file comp-method
  610. ; compile-DEFINE-SLOT-form in file comp-class
  611.  
  612. (define (compile-DOTIMES-form
  613.          forms module-vars bound-vars really-compile
  614.          multiple-values? continue)
  615.     (must-be-list-of-at-least-length forms 1 "DOTIMES: bad syntax")
  616.     (let ((v/c/r (car forms))
  617.           (forms (cdr forms)))
  618.       (must-be-list-of-at-least-length v/c/r 2
  619.        "DOTIMES: Bad var/count/result list")
  620.       (let ((var (car v/c/r))
  621.             (count-form (cadr v/c/r))
  622.             (result (if (pair? (cddr v/c/r)) (caddr v/c/r) #F)))
  623.         (if (not (variable-name? var))
  624.             (dylan::error "DOTIMES -- invalid variable" var forms))
  625.         (if (not (or (null? (cddr v/c/r))
  626.                      (null? (cdddr v/c/r))))
  627.             (dylan::error "DOTIMES -- bad syntax"))
  628.         (let ((name (variable->name var)))
  629.           (compile-forms
  630.            forms module-vars (cons name bound-vars) really-compile #F
  631.            (lambda (body-forms module-vars)
  632.              (compile-forms
  633.               (list count-form result)
  634.               module-vars bound-vars really-compile multiple-values?
  635.               (lambda (c/r-code module-vars)
  636.                 (continue
  637.                  `(DYLAN::DOTIMES ,(car c/r-code)
  638.                                   (LAMBDA () ,(cadr c/r-code))
  639.                                   (LAMBDA (,name) ,@body-forms))
  640.                  module-vars)))))))))
  641.  
  642. ; compile-FOR-form in file comp-sf
  643.  
  644. (define (compile-FOR-EACH-form
  645.          forms module-vars bound-vars really-compile
  646.          multiple-values? continue)
  647.     (must-be-list-of-at-least-length forms 2 "FOR-EACH: bad syntax")
  648.     (for-each
  649.      (lambda (binding)
  650.        (must-be-list-of-length binding 2 "FOR-EACH: bad binding"))
  651.      (car forms))
  652.     (let ((names (map car (car forms)))
  653.           (collections (map cadr (car forms)))
  654.           (end-test-and-return-vals (cadr forms))
  655.           (forms (cddr forms)))
  656.       (compile-forms
  657.        collections module-vars bound-vars really-compile #F
  658.        (lambda (compiled-collections module-vars)
  659.          (compile-forms
  660.           (if (null? end-test-and-return-vals)
  661.               '(#F)
  662.               end-test-and-return-vals)
  663.           module-vars
  664.           (append names bound-vars) really-compile multiple-values?
  665.           (lambda (compiled-et module-vars)
  666.             (compile-forms
  667.              forms module-vars (append names bound-vars)
  668.              really-compile #F
  669.              (lambda (compiled-forms module-vars)
  670.                (continue
  671.                 `(DYLAN::FOR-EACH
  672.                   (LAMBDA (!MULTIPLE-VALUES !DYLAN:NEXT-METHOD ,@names)
  673.                     !MULTIPLE-VALUES    ; Ignored
  674.                     !DYLAN:NEXT-METHOD  ; Ignored
  675.                     ,(if (null? end-test-and-return-vals)
  676.                          `(BEGIN ,@compiled-forms #F)
  677.                          `(IF ,(car compiled-et)
  678.                               (DYLAN::LIST ,@(if (null? (cdr compiled-et))
  679.                                                  (list compiled-sharp-f)
  680.                                                  (cdr compiled-et)))
  681.                               (BEGIN ,@compiled-forms #F))))
  682.                   ,@compiled-collections)
  683.                 module-vars)))))))))
  684.  
  685. ; compile-HANDLER-BIND-form in file comp-exc
  686. ; compile-HANDLER-CASE-form in file comp-exc
  687.  
  688. (define (compile-IF-form forms module-vars bound-vars really-compile
  689.                          multiple-values? continue)
  690.     (must-be-list-of-length forms 3 "IF: invalid syntax")
  691.     (let ((pred (car forms))
  692.           (conseq (cadr forms))
  693.           (alter (caddr forms)))
  694.       (really-compile pred module-vars bound-vars #F
  695.         (lambda (c-pred module-vars)
  696.           (really-compile conseq module-vars
  697.                           bound-vars multiple-values?
  698.             (lambda (c-conseq module-vars)
  699.               (really-compile alter module-vars
  700.                               bound-vars multiple-values?
  701.                 (lambda (c-alter module-vars)
  702.                   (continue `(IF ,c-pred ,c-conseq ,c-alter)
  703.                             module-vars)))))))))
  704.  
  705. ; compile-METHOD-form in file comp-method
  706.  
  707. (define (compile-OR-form
  708.          forms module-vars bound-vars really-compile
  709.          multiple-values? continue)
  710.   (compile-forms
  711.    forms module-vars bound-vars really-compile multiple-values?
  712.    (lambda (code mod-vars)
  713.      (continue `(OR ,@code) mod-vars))))
  714.  
  715. (define (compile-QUOTE-form forms module-vars bound-vars really-compile
  716.                  multiple-values? continue)
  717.   bound-vars really-compile multiple-values?
  718.   (must-be-list-of-length forms 1 "QUOTE: invalid syntax")
  719.   (continue `(QUOTE ,@forms) module-vars))
  720.  
  721. ; compile-SELECT-form in file comp-sf
  722. ; compile-SET!-form in file
  723.  
  724. (define (compile-SETTER-form forms module-vars bound-vars really-compile
  725.                              multiple-values? continue)
  726.   forms module-vars bound-vars really-compile
  727.   multiple-values? continue
  728.   (dylan::error "bad SETTER syntax" forms))
  729.  
  730. (define (compile-UNLESS-form
  731.          forms module-vars bound-vars
  732.          really-compile multiple-values? continue)
  733.   bound-vars                            ; Ignored
  734.   (must-be-list-of-at-least-length forms 1 "UNLESS: bad syntax")
  735.   (compile-forms forms module-vars bound-vars really-compile
  736.                  (if (null? (cdr forms)) #F multiple-values?)
  737.     (lambda (forms module-vars)
  738.       (continue
  739.        `(IF (DYLAN::NOT ,(car forms))
  740.             (BEGIN ,@(if (null? (cdr forms)) (list #F) (cdr forms)))
  741.             #F)
  742.        module-vars))))
  743.  
  744. (define (compile-UNTIL-form
  745.          forms module-vars bound-vars really-compile
  746.          multiple-values? continue)
  747.   multiple-values?
  748.   (must-be-list-of-at-least-length forms 2 "UNTIL: bad syntax")
  749.   (compile-forms forms module-vars bound-vars really-compile #F
  750.     (lambda (forms module-vars)
  751.       (continue
  752.        `(DYLAN::WHILE (LAMBDA () (DYLAN::NOT ,(car forms)))
  753.                       (LAMBDA () ,@(if (null? (cdr forms))
  754.                                        (list #F)
  755.                                        (cdr forms))))
  756.        module-vars))))
  757.  
  758. (define (compile-UNWIND-PROTECT-form
  759.          forms module-vars bound-vars really-compile
  760.          multiple-values? continue)
  761.   (must-be-list-of-at-least-length forms 1 "UNWIND-PROTECT: bad syntax")
  762.   (really-compile (car forms) module-vars bound-vars multiple-values?
  763.     (lambda (c-protect module-vars)
  764.       (really-compile `(BEGIN ,@(cdr forms))
  765.                       module-vars bound-vars #F
  766.         (lambda (c-cleanup module-vars)
  767.           (continue
  768.            `(DYLAN::DYNAMIC-WIND (LAMBDA () 'DONE)
  769.                                  (LAMBDA () ,c-protect)
  770.                                  (LAMBDA () ,c-cleanup))
  771.            module-vars))))))
  772.  
  773. (define (compile-WHEN-form
  774.          forms module-vars bound-vars really-compile
  775.          multiple-values? continue)
  776.   (must-be-list-of-at-least-length forms 1 "WHEN: bad syntax")
  777.   (compile-forms forms module-vars bound-vars really-compile
  778.                  (if (null? (cdr forms)) #F multiple-values?)
  779.     (lambda (forms module-vars)
  780.       (continue
  781.        `(IF ,(car forms)
  782.             (BEGIN ,@(if (null? (cdr forms)) (list #F) (cdr forms)))
  783.             #F)
  784.        module-vars))))
  785.  
  786. (define (compile-WHILE-form
  787.          forms module-vars bound-vars really-compile
  788.          multiple-values? continue)
  789.   (must-be-list-of-at-least-length forms 1 "UNTIL: bad syntax")
  790.   (compile-forms forms module-vars bound-vars really-compile
  791.                  (if (null? (cdr forms)) #F multiple-values?)
  792.     (lambda (forms module-vars)
  793.       (continue
  794.        `(DYLAN::WHILE (LAMBDA () ,(car forms))
  795.                       (LAMBDA () ,@(if (null? (cdr forms))
  796.                                        (list #F)
  797.                                        (cdr forms))))
  798.        module-vars))))
  799.